-!NILISP.MAC←UCILSP.MAC
- /-/-/-/-/-/-/-/-/-/ BEGINNING OF CONFLICT   1 \-\-\-\-\-\-\-\-\
-1,7
	TITLE	LISP INTERPRETER
	SUBTTL	NOTES  TO SYSTEM PROGRAMMERS		

;	ASSEMBLY SWITCHES OF  INTEREST
;
;	SWITCH		EXPLANATION,  COMMENTS  ETC.
;	ALTMOD		FOR ALTMODE CHARACTER. OLD WAS 175
;			NOW IT'S 33 FOR 506
;	QALLOW		ENABLES  ACCESS  TO QMANGR, ONLY  IF YOUR
;			SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES 
;			ASSOCIATED WITH  THE  CODE
;	OLDNIL		OLD STANFORD NIL. CODE TO MAKE CAR AND CDR
;			OF NIL INCOMPLETE AS OF 8/30/73
;	NONUSE		OLD STANFORD VERSIONS  OF  MEMQ, AND  ETC.
;			THAT  RETURNED  T OR NIL.
;	SYSPRG		PROJECT NUMBER IF NOT ON SYS:.
;	SYSPN		PROGRAMMER NUMBER IF NOT ON SYS:
;	SYSDEV		DEVICE LOCATION OF SYSTEM.
;			NOTE THAT  THE ABOVE THREE ARE WHERE LISP
;			EXPECTS  TO  FIND THE  LOADER,THE
;			SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
;			THE FUNCTION (SETSYS ...) ONLY CHANGES THE
;			EXPECTED LOCATION OF THE HI-SEG
;	**USE  FOLLOWING AT OWN  RISK**

;	HASH		NUMBER OF  HASH BUCKETS  WHEN STARTING
;	ALVINE		STANFORD EDITOR (WHO WOULD WANT IT?)
;			1 FOR ALVINE, 0 FOR NO ALVINE
;	STPGAP		ANOTHER  STANFORD  EDITOR

;	COMMENTS
;	THERE ARE BASICALLY TWO SETS OF COMMENTS IN THE CODE.
;	THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS. 
;	THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
;	TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
;	CHANGES, OR ADDITIONAL COMMENTS.
;	($'S ARE USUALLY DARYLE LEWIS, 
;	#'S ARE GENERALLY JEFF JACOBS,
;	AND %'S ARE GENERALLY BILL EARL.)


	PAGE
		SUBTTL AC DEFINITIONS AND EXTERNALS 		
	TWOSEG
	OLDNIL==1		;## NOT COMPLETE

IFNDEF	NONUSE		<NONUSE==0>
IFNDEF	QALLOW		<QALLOW==1>
;SYSPRG==667	;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
;SYSPN==2	;SAME HERE
-2,2
TITLE ILISP INTERPRETER
-6,7
- /-/-/-/-/-/-/-/-/-/-/-/-/ END OF CONFLICT   1 \-\-\-\-\-\-\-\-\
-17,19
-26,26
DEFINE SYSNAM <SIXBIT /ILISP2/>				;	*** MJC
-80,82
OPDEF SKPINL	[TTCALL 14,]	;## BETTER FOR TALK THAN SKPINC
OPDEF TALK [PUSHJ P,TTYCLR]	;## TURN OF CONTROL O
-99,99
IFNDEF ALTMOD,<ALTMOD==33>
-142
CNTLR==22	;CH TO RESTORE SYSTEM OBLIST 3/28/73
-143:
-170,171
	PAGE

		SUBTTL TOP LEVEL AND INITIALIZATION  
- /-/-/-/-/-/-/-/-/-/ BEGINNING OF CONFLICT   2 \-\-\-\-\-\-\-\-\
-178,186
;	CAME	0,STNIL	;$$UNBIND STACK IF REGS LOOK OK		*** MJC
;	JRST	GETHGH	;GO GET HIGH SEGMENT			*** MJC
;	MOVE	B,SC2						*** MJC
;	PUSHJ	P,UBD	;$$UNBIND STACK				*** MJC
;	JRST STRT	;go to re-allocator			*** MJC
;GETHGH:	CALLI	RESET					*** MJC
;	MOVSI	A,1						*** MJC
;IFE STANSW,<	CALLI	A,CORE	;ELIMINATE ANY OLD HIGH SEGS.	*** MJC
;	HALT >							*** MJC
-185,191
	CALLI	A,CORE		;ELIMINATE ANY OLD HIGH SEGS.
	HALT
	MOVEI	A,HGHDAT
	CALLI	A,GETSEG	;GET THE PROPER HIGH SEG
	HALT
- /-/-/-/-/-/-/-/-/-/-/-/-/ END OF CONFLICT   2 \-\-\-\-\-\-\-\-\
-192,200
       	MOVE	A,HGHDAT+1	; Get high segment name		*** MJC
	CALLI	A,400016	; Attach to high seg if poss.	*** MJC
	CAIN	A,4	; If err=4 (seg alrdy there) ok too	*** MJC
	JRST	SGPROT		; Success!			*** MJC

	CALLI	400017		; Detach stray segments.	*** MJC
	MOVE	A,HGHDAT	; Get device name for OPEN.	*** MJC
	MOVEM	A,INTDAT+1	; Move into parm list for OPEN.	*** MJC
	OPEN	0,INTDAT  	; Init ch 0 to dump mode.	*** MJC
	JRST	NOSEG		; Couldn't do it?		*** MJC
	MOVE	A,SGPPPN	; Get ppn of high seg file.	*** MJC
	MOVEM	A,HGHDAT+4	; Store for LOOKUP.		*** MJC
	LOOKUP	0,HGHDAT+1	; Find file containing high seg	*** MJC
	JRST	NOSEG		; No high seg file -- collapse	*** MJC
	HLRE	A,HGHDAT+4	; Ppn was replaced by -length	*** MJC
	MOVNS	A		; Fix up for CORE2.		*** MJC
	CALLI	A,400015	; Grab core for high segment.	*** MJC
	JRST	NOSEG		; Can't get it?			*** MJC
	MOVE	A,HGHDAT+1	; Name the high segment.	*** MJC
	CALLI	A,400036	; SEGNM2 uuo.			*** MJC
	JRST	NOSEG		; Pretty weird.			*** MJC
	MOVEI	A,SHRST-1	; For dump mode input.		*** MJC
	HRRM	A,HGHDAT+4	;				*** MJC
	INPUT	0,HGHDAT+4	; Fill high seg with goodies.	*** MJC
	CLOSE	0,1		; Destroy fingerprints.		*** MJC
SGPROT:	MOVEI	A,DEBUGO	;SET THE REE ADDRESS
	HRRM	A,JOBREN
	MOVE	A,HGHDAT+1	; Decide whether or not to 	*** MJC
	CAME	A,[SYSNAM]	;   protect segment.		*** MJC
	JRST	STRT		; Segment was not system's	*** MJC
	CALLI	36		; Write-protect segment.	*** MJC
	HALT			; rather than turn him loose.	*** MJC
	JRST	STRT		;GO TO ALLOCATE STORAGE
NOSEG:	OUTSTR	[ASCIZ/CAN'T GET HIGH SEGMENT!/] ;		*** MJC
	HALT					;		*** MJC
HGHDAT:	SYSDEV			; All used by LOOKUP and ENTER	*** MJC
	SYSNAM			; High segment job & file name	*** MJC
	0			; High seg file extension.	*** MJC
	0	
	0			; PRG,PPN of high seg file.	*** MJC
				; Also file length after LOOKUP	*** MJC
				; Used as dump wd cmd list.	*** MJC
	0
INTDAT:	17			; Data mode.			*** MJC
	SYSDEV			; Dev name (defd before OPEN)	*** MJC
	0			; Buffer indicators (none)	*** MJC
SGPPPN:	XWD	SYSPRG,SYSPN	; High seg file area		*** MJC
PATCHL:	BLOCK	20
 >
-201:
-208
	CAIN	0,CNTLR
			; RESTORES SYSTEM OBLIST
	JRST	[HRRI	0,OBTBL(S)
		 HRRM	0,VOBLIST(S)
		 JRST	DEBUGO+2]
			; AND TRIES FOR ANOTHER CONTROL CHARACTER
-263,264
IFN OLDNIL	<HRROI	0,CNIL2(S)>	;INITIALIZE  NIL
IFE OLDNIL	<SETZ	0,	>
	MOVEM 0,STNIL#		;$$SAVE FOR REG CHECK AT START TIME
	MOVEI	A,CNIL2(S)	;## GET PROP  LIST  OF NIL
	MOVEM	A,NILPRP#	;##  AND SAVE IT FOR  GET ETC.

-267

-268:	SKIPN F	
-288,288

INITFL:	EXCH	A,INITF1#	;## NEW INIT FILE LIST
	POPJ	P,		;## RETURN THE OLD ONE

-300
COMMENT %
	;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
-321,322
	%

	;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
	;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
	;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
	;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
	;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
	;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
	;## FILES EXISTENCE IS STILL OPTIONAL

BOOTS:	SETOM	BSFLG#		;## INDICATE BOOTSTRAP DONE
	SKIPN	T,INITF1#	;## GET INIT FILE LIST IF IT EXISTS
	JRST	BOOTOT		;## NOPE, EXCISE AND RETURN
	MOVEI	A,TRUTH(S)	;## USE CHANNEL T
	PUSHJ	P,INPUT2	;## SET UP
	PUSHJ	P,ININIT	;## LOOK UP
	JUMPN	A,BOOTOK	;## IT'S THERE, GO TO IT
	JUMPE	T,BOOTOT	;## NOT THERE AND NO OTHERS REQUESTED
	PUSHJ	P,SETINA	;## SET UP FOR THE REST
	PUSHJ	P,ININIT	;## LOOK UP (SECOND FILE IN LIST)
	JUMPE	A,AIN.7		;## NOT THERE, ERROR MESSAGE
BOOTOK:	MOVEI	A,TRUTH(S)	;##(INC T NIL)
	SETZ	B,
	PUSHJ	P,INC		;## SELECT
	MOVEI	A,READAT(S)	;## SET UP [(EVAL (READ))]
	PUSHJ	P,NCONS		;## (READ)
	PUSHJ	P,NCONS		;## ((READ))
	MOVEI	B,EVALAT(S)
	PUSHJ	P,XCONS		;##(EVAL(READ))
	PUSHJ	P,NCONS		;## [(EVAL(READ))]
	PUSH	P,A
	MOVE	A,(P)
	PUSHJ	P,ERRSET	;## AN EVAL-READ LOOP. PROTECTED AGAINST
	CAIE	A,$EOF$(S)	;## ALL ERRS EXCEPT $EOF$ AND ERRORX
	JRST	.-3		;## LOOP
BOOTOT:	PUSHJ	P,EXCISE
	JRST	ERR
	PAGE

		SUBTTL APR INTERRUPT ROUTINES 
-351,351
	PAGE

		SUBTTL UUO HANDLER AND SUBR CALL ROUTINES 
-395,395
-396:	SKIPA T,TT
-515
	MOVNS T
	DPB T,[POINT 4,JOBUUO,ACFLD]
-549,549
	PAGE

		SUBTTL ERROR HANDLER AND BACKTRACE 
-591,591
IFN OLDNIL<	HRROI NIL,CNIL2(S)>
IFE OLDNIL<	SETZ	NIL,	>

-598
	HRRZ	C,VOBLIST(S)	;## GET CURRENT OBLIST
	HRRM	C,RHX5
	HRRM	C,RHX2		;## AND UPDATE LOCATIONS WHICH REF OBLIST
-686,686
ERREND:	SETZ	A,		;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
-687:	SKIPN	UUO2		;$$NO ERRORX IF OVERFLOW ERROR
-690,690
	JRST	RERX		;$$BOUNCE BACK TO ERRORX
-694
	PUSHJ	P,%CLRBFI	;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
				;##  OF TYPE AHEAD
-736,736
	SETZM	CONSVA	;## RESET CONS COUNT
	SETZM	GCTIM	;## RESET GC TIME
	JRST	EXCISE	;## EXCISE
-845,848
	PAGE

		SUBTTL TYI  AND TYO  
;input
ITYI:	PUSHJ P,TYI	;## RETURN ASCII VALUE OF INPUT  CH
-852,852
TYI:	MOVEI AR1,1	;## TO TEST FOR LINED TYPESEQUENCE #, ETC
-853:	PUSHJ P,TYIA
-860,862
TYIA:	SKIPE A,OLDCH		;##  IF CH  IN OLDCH
	JRST	TYI1		;## TAKE CARE OF IT
TYID:	XCT	TYI2		;##  INPUT A CHARACTER
-867,869
	XCT	TYI3A		;## SEE IF LINED TYPE WORD
REMOTE<TYI3A:	TDNN AR1,@X>	;pointer
	POPJ	P,		;## NO, OK

-886,886
TYIEOF:		JRST	TYI2Q		;END OF FILE>
-895
	PUSHJ P,ININIT	;## INIT THE FILE
	JUMPE A,AIN.7	;## CAN'T FIND FILE, ERROR
-903,903
	TALK
-904:	MOVEI A,$EOF$(S)	;we are done
-941,949
ERRCH:	MOVEI	A,-INUM0(A)	;## CHANGE BELL CHARACTER
	EXCH	A,ERRCHR	;## RETURN OLD CHARACTER
	JRST	FIX1A		;## CONVERT IT

REMOTE	<
	ERRCHR:	BELL
	>

TTYI:	SKIPE DDTIFG		;## DDT MODE?
	JRST TTYID
	INCHSL A	;single char if line has been typed
	JRST 	[OUTCHR PROMCH#	;$$OUTPUT PROMPT CHARACTER		
		INCHWL A	;wait for a line
		JRST .+1]

TTYXIT:	CAME	A,ERRCHR	;## BELL, NEED NOT BE ↑G
-958,959
TTYID:	INCHRW A	;single character input ddt submode style
-1060,1061
TTYCLR:	SKPINL	;## SKPINL FIXES RUBOUT PROBLEM IN TYPE AHEAD
	JFCL
-1073,1073
		SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL 
-1107,1115

;##	SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
;##	AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT AN ATOM AND B=0
;##	DEVICE OR QUEUE.

DEVCHK:	PUSHJ	P,NXTIO		;## MAKE SIXBIT IF AN ATOM
	LDB	B,[POINT 6,A,35];## GET LAST CHAR
	CAIN	B,':'		;## DEVICE?
	TRZA	A,77		;## YES, CLEAR CHAR BUT LEAVE B INTACT
	SETZ	B,		;## NO, CLEAR B
	POPJ	P,		;## DONE, IF A=0 OR B=0, NOT A DEVICE

;##	SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
;##	NO DEVICE SPECIFIED.
IOSUB:	MOVEM	T,DEVDAT#	;## SAVE ARG FOR ERRORS
	SKIPE	DEV		;## DEVICE ALREADY SPECIFIED?
	JRST	.+4		;## YES, FORGET DEFAULT
	SETZM	PPN		;## CLEAR PPN
	MOVSI	A,'DSK'		;## STORE DSK AS DEFAULT
	MOVEM	A,DEV
	PUSHJ	P,DEVCHK	;## SEE IF DEVICE SPECIFIED
	JUMPE	A,IOPPN		;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
	JUMPE	B,IOFIL		;## NOT A DEVICE, MUST BE FILE NAME
	SETZM PPN
IODEV2:	MOVEM A,DEV
-1116:	PUSHJ P,INXTIO
-1121,1131
	PUSHJ	P,CNVPPN	;## CONVERT PPN
	MOVEM	A,PPN
-1135,1137
IOFIL:	JUMPN A,IOFIL2	;was it an atom
-1173
		;##  LEFT HALF OF  A CHANNEL TABLE ENTRY IS THE  REMAINING
		;## FILE LIST. RH POINTS TO EXTENDED HEADER.
-1241,1245
INPUT1:	PUSHJ P,CHNSUB	;determine channel name
	MOVEI	AR1,(A)		;## SAVE CH NAME
	EXCH	AR1,(P)		;## EXHANGE WITH RETURN ADDR
	PUSH	P,AR1		;## AND STUFF THE RETURN ADDR. IN
INPUT2:	PUSHJ	P,TABSRC	;## GET PHYSICAL CHANNEL NUMBER
	MOVEM	A,CHANNEL	;## SAVE IT
	SETZM	DEV		;## CLEAR DEV SO THAT WE CAN
				;## DEFAULT IF APPROPRIATE
	JRST	SETIN1		;## SET UP FOR INITIALIZTION

INPUT:	PUSHJ	P,INPUT1
	PUSHJ	P,ININIT
INFAIL:	JUMPE	A,AIN.7		;## CAN'T FIND FILE
	JRST	POPAJ

BINPUT:	PUSHJ	P,INPUT1	;## IMAGE BINARY INPUT
	PUSHJ	P,BNINIT
	JRST	INFAIL

ISFILE:	JUMPE	A,.+5		;## ROUTINE TO TELL USER IF A FILE EXISTS
	PUSH	P,A		;## SAVE A IF NON-NIL
	MOVEI	A,(B)		;## GET THE FILE NAME
	PUSHJ	P,NCONS		;## (FILNAM)
	POP	P,B		;## GET THE DEVICE BACK
	PUSHJ	P,XCONS		;## (DEV FILNAM) OR (FILNAM) WHEN HERE
	PUSH	P,A		;## SAVE IT FOR RETURN
	PUSHJ	P,RENSUB	;## SEE IF IT'S THERE
	PUSH	P,A		;## SAVE THE ANSWER
	PUSHJ	P,RENCLR	;## CLEAR THE CHANNEL
	POP	P,A		;## ANSWER IN A
	JUMPN	A,POPAJ		;## IF NON-NIL, THEN IT'S THERE
	POP	P,B		;## POP ANSWER OFF
	POPJ	P,		;## AND RETURN NIL

RENSUB:	MOVEM	A,DEVDAT	;## SAVE IT FOR ERROR MSGS
	PUSHJ	P,GENSYM	;## DON'T CLOBBER CURRENT CHANNELS
	MOVE	T,DEVDAT	;## GET IT BACK
	PUSHJ	P,INPUT2	;## SET UP AND OPEN
	JRST	ININIT		;## AND INIT

RENAME:	PUSHJ	P,RENSUB	;## RENAME SETUP
	JUMPE	A,RENCLR	;## NIL IF CAN'T FIND FILE
	PUSHJ	P,SETINA	;## PROCESS THE NEW NAME
	XCT	RNAME		;## EXECUTE
	JRST	RENCLR		;## RETURN NIL IF FAILURE
	PUSHJ	P,RENCLR	;## CLEAR CHANNEL
	JRST	TRUE		;## AND RETURN T IF GOOD

REMOTE	<
RNAME:	RENAME	X,LOOKIN	;## RENAME FILE
	>
DELERR:	PUSHJ	P,AIOP
	PUSHJ	P,RENCLR	;## KILL THE CHANNEL
	ERR1	[SIXBIT /CAN'T DELETE FILE !/]

DELETE:	PUSHJ	P,RENSUB	;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
	JRST	.+2		;## ALREADY INIT'ED
DELET1:	PUSHJ	P,ININIT	;## INIT AND LOOKUP
	JUMPE	A,DELET2	;## IF FILE NOT THERE IGNORE
	SETZM	LOOKIN		;## BLAST FILE NAME
	SETZM	EXT		;## AND EXTENSION
	XCT	RNAME		;## AND RENAME OUT OF EXISTENCE
	JRST	DELERR		;## RENAME FAILURE
DELET2:	JUMPE	T,RENCLR	;## DONE
	MOVEM	T,DEVDAT	;## SAVE REST OF LIST FOR MSGS.
	PUSHJ	P,SETINA	;## PROCESS NEXT FILE
	JRST	DELET1		;## AND DO IT AGAIN

RENCLR:	PUSH	P,CHANNEL	;## CLEAR CHANNEL
	SETO	B,		;## FAKE (INC RENCHANNEL T)
	PUSHJ	P,IOSEL		;## RELEASE THE CHANNEL
	JRST	POPAJ		;## RETURN NIL (IOSEL CHANGED THINGS)


	;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR

UFDINP:	PUSH	P,A
	MOVEI	T,(B)
	PUSHJ	P,TABSRC
	MOVEM	A,CHANNEL	;## HAVE A CHANNEL
	MOVE	A,[XWD 'DSK','UFD']
	HRLZM	A,EXT
	HLLZM	A,DEV
	SETZ	B,
	AOBJP	B,.+1		;## UFD'S SHOULD BE ON [1,1]
	MOVEM	B,PPN
	SKIPN	A,T
	PUSHJ	P,MYPPN		;## IF B=NIL, DEFAULT TO USER'S PPN
	MOVEM	A,DEVDAT
	PUSHJ	P,CNVPPN	;## CONVERT PPN
	SETZ	T,		;## ZAP T (NO MORE FILES)
	PUSHJ	P,SETIN2	;## SETUP 
	PUSHJ	P,BNINIT	;## INIT AS BINARY
	JUMPE	A,ERR		;## ERR NIL IF NOT THERE
	PUSHJ	P,ININBF	;## SET UP BUFFERS
	JRST	POPAJ		;## RETURN CHANNEL
MYPPN:	GETPPN	A,		;## GET PPN
	CAI			;## WIERD SKIP RETURN ON THIS UUO
	HLRZ	C,A		;## ASSUME PPN'S ARE INUMS
	HRRZI	A,INUM0(A)	;## CONVERT
	PUSHJ	P,NCONS	
	HRRZI	B,INUM0(C)
	JRST	XCONS		;## (PROJ PRGRM)

CNVPPN:	MOVS	A,(A)		;## ASSUME PPNS INUMS
	HRRI	A,-INUM0(A)	;## LH=CDR, RH=CAR
	MOVSS	A		;## SWAP HALVES
	HLR	A,(A)		;## RH=CADR NOW
	HRRI	A,-INUM0(A)
	POPJ	P,


SETINA:	MOVE	A,CHANNEL	;## FOR ROUTINES THAT PROCESS MORE
	HRRZ	C,CHTAB(A)	;## AND KEEP THE CHANNEL IN CHANNEL
-1252,1254
SETIN1:	PUSHJ P,IOSUB	;get device and file name
SETIN2:	MOVEM A,LOOKIN	;file name
	MOVE A,DEV
	MOVEM	A,BDEV		;## ALLOW IMAGE BINARY MODE
-1255:	CALLI A,DEVCHR
-1261
	DPB A,[POINT 4,BNINIT,ACFLD]	;## FOR IMAGE BINARY
	DPB A,[POINT 4,RNAME,ACFLD]	;## FOR RENAME
-1267,1279
	MOVEM A,DEV1		;pointer to bufdat
	MOVEM	A,BDEV1		;## IMAGE BINARY MODE
	POPJ	P,		;## SET UP FOR INITIALIZTION
REMOTE<

BNINIT:	INIT	X,13		;## INIT DEVICE IN IMAGE BINARY
BDEV:	X
BDEV1:	X
	JRST	AIN.7		;## CAN'T INIT
	JRST	INITOK
ININIT:	INIT X,
DEV:	X
DEV1:	X
	JRST AIN.7		;cant init
INITOK:	PUSH B,DEV
	PUSH B,PPN
INLOOK:	LOOKUP X,LOOKIN
	JRST	FALSE		;## LET SOMEONE ELSE HANDLE THE ERROR
	JRST IRET1>

IRET1:	PUSH B,[0]	;oldch

-1283,1289
	>

	ADDI B,4
	HRRM B,JOBFF
	JRST	ININBF

REMOTE<
ININBF:	INBUF X,NIOB
	JRST	TRUE	;## RETURN FROM GOOD LOOKUP WITH T

-1300
	SETZM	DEV	;## CLEAR DEV FOR DEFAULT TO DSK:
-1348,1348
IOSEL1:	DPB C,[POINT 4,RLS,ACFLD]
-1349:	XCT RLS
-1469,1469
	PAGE
	SUBTTL	QMANGR INTERFACE

;## 	CODE TO ALLOW LISP USER'S TO CALL DEC'S  QMANGR, ALLOWING
;## 	PRINTING OF FILES AND CREATION OF JOBS
;## 	SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
;## 	SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
;## 	DOES A PUSHJ TO 400010. IT ALSO CHANGES JOBREN SO
;## 	THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
;## 	ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
;## 	PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
;## 	RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
;## 	CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
;## 	IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
;## 	/LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
;## 	THAT IS NOT INCLUDED. SEE APPROPRIATE
;## 	DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73


IFN QALLOW <
	IFNDEF	QSWEXT	<QSWEXT=0>	;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED 
	IFE	QSWEXT	<NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
	IFN	QSWEXT	<NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
	IFNDEF	QLSTOK	<QLSTOK==0>
	IFNDEF	QTIME	<QTIME==0>


	;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
	;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
	;%% DEC SOFTWARE.  THE FOLLOWING DEFINITIONS ALLOW
	;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER 
	;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
	;%% THE QMANGR SOURCE BELOW.
	COMMENT &
	INPPAR==32	;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
	OUTPAR==24	;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
	DIFPAR==INPPAR-OUTPAR	;##  DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
	FILPAR==14	;## NUMBER WORDS IN FILE PARAMTER AREA




			;## LOCATIONS IN PARAMETER AREAS
	;## MAIN AREA
	Q.MEM==0		;## MEMORY FOR QMANGR
	Q.OPR==1		;## REQUESTED OPERATION
	Q.LEN==2		;## RH=NUMBER OF FILES IN REQUEST
	Q.DEV==3		;## REQUESTED QUEUE
	Q.PPN==4		;## PPN REQUESTING
	Q.JOB==5		;## JOB NAME
	Q.SEQ==6		;## JOB SEQUENCE #
	Q.PRI==7		;## EXTERNAL PRIORITY
	Q.PDEV==10		;## 
	Q.TIME==11		;## 
	Q.CREA==12		;## 
	Q.AFTR==13		;## AFTER PARAMETER
	Q.DEAD==14		;## DEADLINE PARAMETER
	Q.CNO==15
	Q.USER==16		;## AND 17
	;## INPUT SECTION OF MAIN PARAMETER AREA
	Q.IDEP==20			;## RESTART AND DEPENDENCY PARAMTERS
	Q.ILIM==21		;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
				;## +2 IS PTP LIMIT AND PLOT LIMIT
	Q.IDDI==24		;## THRU 31
	Q.IEND==31		;## LAST LOC OF INP AREA
	;## OUTPUT SEECTION OF MAIN PARAMETER AREA
	Q.OFRM==20		;## FORM PARAMTER
	Q.OSIZ==21		;## LH=LIMIT
	Q.ONOT==22
	Q.OEND==23		;## LAST LOC OF OUTPUT AREA
	;## FILE PARAMETER AREA (ONE FOR EACH FILE)
	Q.FSTR==0		;## FILE STRUCTURE
	Q.FDIR==1		;## THRU 6, DIRECTORY
	Q.FNAM==7		;## FILE NAME
	Q.FEXT==10		;## FILE EXTENSION
	Q.FRNM==11		;## RENAME NAME (0)
	Q.FBIT==12	
	Q.FMOD==13		;## SPACING, FILE DISPOSAL, COPIES
	&			;%% END OF DELETED DEFINITIONS

	;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
	;%% ON 24 OCTOBER 1973

	QDEFST==.		;%% WHERE TO RELOC TO AFTERWARDS
	RELOC	0		;%% TO SAVE CORE AND AVOID CONFUSION
				;%% COMMENTS BELOW ARE AS COPIED 
				;%% FROM QMANGR
	PHASE	0
Q.ZER:!			;START OF QUEUE PARAMETER AREA
Q.MEM:!	 BLOCK	1	;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
Q.OPR:!	 BLOCK	1	;OPERATION CODE
    QO.CRE==1		;CREATION OPERATION
    QO.LST==4		;LIST OPERATION
    QO.MOD==5		;MODIFY OPERATION
    QO.KIL==6		;KILL OPERATION
    QO.DEL==10		;DELETE OPERATION
    QO.REQ==11		;REQUEUE OPERATION
    QO.FLS==12		;FAST LIST OPERATION
Q.LEN:!	 BLOCK	1	;LENGTHS IN AREA
Q.DEV:!	 BLOCK	1	;DESTINATION DEVICE
Q.PPN:!	 BLOCK	1	;PPN ORIGINATING REQUEST
Q.JOB:!	 BLOCK	1	;JOB NAME
Q.SEQ:!	 BLOCK	1	;JOB SEQUENCE NUMBER
Q.PRI:!	 BLOCK	1	;EXTERNAL PRIORITY
Q.PDEV:! BLOCK	1	;PROCESSING DEVICE
Q.TIME:! BLOCK	1	;PROCESSING TIME OF DAY
Q.CREA:! BLOCK	1	;CREATION TIME
Q.AFTR:! BLOCK	1	;AFTER PARAMETER
Q.DEAD:! BLOCK	1	;DEADLINE TIMES
Q.CNO:!	 BLOCK	1	;CHARGE NUMBER
Q.USER:! BLOCK	2	;USER'S NAME

Q.I:!			;START OF INPUT QUEUE AREA
Q.IDEP:! BLOCK	1	;DEPENDENCY WORD
Q.ILIM:! BLOCK	3	;JOB LIMITS
Q.IL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.IDDI:! BLOCK	6	;JOB'S DIRECTORY
Q.II:!			;START OF INPUT FILES AREA

	PHASE	Q.I
Q.O:!			;START OF OUTPUT QUEUE AREA
Q.OFRM:! BLOCK	1	;FORMS REQUEST
Q.OSIZ:! BLOCK	1	;LIMIT WORD
Q.OL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.ONOT:! BLOCK	2	;ANNOTATION
Q.FF:!
	PHASE	0
Q.F:!			;DUPLICATED AREA FOR EACH REQUESTED FILE
Q.FSTR:! BLOCK	1	;FILE STRUCTURE
Q.FDIR:! BLOCK	6	;ORIGINAL DIRECTORY
Q.FNAM:! BLOCK	1	;ORIGINAL NAME
Q.FEXT:! BLOCK	1	;ORIGINAL EXTENSION
Q.FRNM:! BLOCK	1	;RENAMED FILE NAME (0 IF NOT)
Q.FBIT:! BLOCK	1	;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
Q.FMOD:! BLOCK	1	;FILE SWITCHES
X.LOG==1B1	;FILE IS LOG FILE
X.NEW==1B2	;OK IF FILE DOESNT EXIST YET
Q.FRPT:!BLOCK	2		;/REPORT

Q.FLEN==.-Q.F
	DEPHASE
	PHASE	0
Q.FDRM:! BLOCK	6	;DIRECTORY MASK FOR MODIFY
Q.FNMM:! BLOCK	1	;FILE NAME MASK FOR MODIFY
Q.FEXM:! BLOCK	1	;EXTENSION MASK FOR MODIFY
Q.FMDM:! BLOCK	1	;MODIFIER MASK FOR MODIFY
Q.FMLN==.-Q.F	;LENGTH OF MODIFY BLOCK

	DEPHASE
	RELOC	QDEFST		;%% MAKE UP FOR INCREASE IN LOCATION 
				;%% COUNTER

	INPPAR==Q.II		;%% SIZE OF MINIMUM INPUT AREA
	OUTPAR==Q.FF		;%% SIZE OF MINIMUM OUTPUT AREA
	OUTPR1==OUTPAR-1	;%% MACRO DOESN'T LIKE EXPRESSIONS
	DIFPAR==INPPAR-OUTPAR	;%% DIFFERENCE IN AREAS
	FILPAR==Q.FLEN		;%% FILE DATA AREA
	LOWLEN==↑D110		;## AREA NEED FOR PARAMETER
				;## AREA TO QMANGR
	LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
	NQS==6			;## NUMBER OF QUEUES


		;## QUEUE ERRORS

QILLSW:	HLRZ	A,(T)		;## GET SWITCH THAT  CAUSED ERROR
	PUSHJ	P,PRINT
	STRTIP	[SIXBIT /  =ILL. SWITCH SPEC.!/]
	PUSHJ	P,CONCOR	;## SAVE THAT CORE
QERR1:	ERR1	[SIXBIT /ERROR IN QUEUE REQUEST!/]



QUEUE:	SKIPN	T,A		;## ERROR IF NO ARGS
	JRST	QERR1
	PUSHJ	P,DEVCHK	;## SEE IF QUEUE SPECIFIED
	JUMPE	A,NOQUE		;## IF A=0 THEN NOT A QUEUE
	JUMPE	B,NOQUE		;## IF B=0 THEN NOT A QUEUE
	MOVE	AR2A,A
	HLRZ	B,A		;## GET FIRST THREEE LETTERS
	MOVEI	C,NQS		;## GET NUMBER OF PERMISSIBLE QUEUES
	SOJL	C,NOQUE		;## IF EXHAUSTED TABLE, THEN  NO QUEUE
	MOVE	A,QSTABL(C)	;## PERMISSIBLE QUEUES
	JSP	R,CHKGO		;## JUMP TO ROUTINE THAT COMPARES RH AND GO
				;## TO LH OF A IFF RH(A)=B
	JRST	.-3		;## LOOP



	;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH

QSTABL:	XWD	INPREQ, 'INP'
	XWD	OUTREQ,	'LPT'
	XWD	OUTREQ,	'PTP'
	XWD	OUTREQ,	'PTP'
	XWD	OUTREQ,	'CDP'
	XWD	OUTREQ,	'PLT'

OUTREQ:	TDZA	A,A		;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
INPREQ:	MOVEI	A,DIFPAR	;## HERE TO PROCESS INPUT REQUEST
	JRST	QGOOD		;## FOUND A QUEUE
NOQUE:	MOVSI	AR2A,'LPT'	;## HERE IF NO QUEUE, DEFAULT=LPT
	TDZA	A,A		;## CLEAR A AND SKIP
QGOOD:	HRRZ	T,(T)		;## HERE IF QUEUE SPECIFIED
	ADDI	A,OUTPAR	;## A IS ZERO OR INPPAR
QSETUP:	PUSH	P,B		;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
	HRLZI	TT,(A)		;## SAVE LNENGTH OF AREA
	PUSHJ	P,TEMCOR	;## EXPAND CORE
	HRRI	TT,(A)		;## START ADDR OF MAIN AREA
	MOVE	A,TT
	PUSHJ	P,CLRBLK	;## CLEAR AREA
	MOVEM	AR2A,Q.DEV(TT)
	MOVEI	C,LHLEN		;## GET LENGTHS FOR HEADER AND FILE AREAS
	MOVE	A,[XWD 500,500]
	HRLZM	A,Q.OSIZ(TT)	;## ASSUME OUTPUT HERE
	POP	P,B		;## RESTORE LEFT THREE LETTERS
	CAIE	B,'INP'		;## WAS IT AN INPUT REQUEST?
	JRST	QUEUE1		;## NO SHOULD  BE OK
	ADDI	C,DIFPAR←9	;## UPDATE HEADER LENGTH
	MOVEM	A,Q.ILIM+1(TT)	;## MAX PAGES AND CARD PUNCH
	MOVEM	A,Q.ILIM+2(TT)	;## MAX PAPER TAPE AND  PLOTTER
	HRLI	A,↑D256
	MOVEM	A,Q.ILIM(TT)	;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
				;##  CHECKED HERE)
	MOVSI	A,400000	;## SET BIT 0 FOR NOT RESTARTABLE
	HLLZM	A,Q.IDEP(TT)	;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
QUEUE1:	MOVSM	C,Q.LEN(TT)	;## SET HEADER AND FILE AREA LENGTHS
	GETPPN	A,		;## SET REQUESTING PPN
	CAI			;## WEIRD SKIP RETURN ON THIS UUO
	MOVEM	A,Q.PPN(TT)
	SETZ	REL,		;## CLEAR REG FOR FILE AREA
	MOVEI	A,20	;## PRIORITY DEFAULT
	MOVEM	A,Q.PRI(TT)
	AOSA	Q.OPR(TT)	;## SET DEFAULT FOR REQUEST TYPE=/CREATE
	;##  BASIC LOOP FOR HANDLING THE SWITCHES

QLOOP:	HRRZ	T,(T)		;## HERE IF ROUTINE DID NOT MOVE ARG 
QSELF:	JUMPE	T,QDONE
	PUSHJ	P,DEVCHK	;## SEE IF DEVICE OR ATOMIC FILE NAME?
	JUMPN	B,QFILEA	;## IF B#0 THEN DEVICE
	JUMPN	A,QFILE		;## IF A#0 THEN ATOMIC FILE
	HLRZ	C,(T)		;## WELL, SEE IF SWITCH
	HRRZ	A,(C)		;## CDAR
	PUSHJ	P,ATOM		;## ATOM?
	JUMPN	A,QFILE		;## YES, THEREFORE(FILE.EXT)
	HLRZ	B,(C)		;## CAAR
	SUBI	B,(S)		;## STRIP OFF RELOCATION
	HRRZI	C,NSWS		;## GET NUMBER OF SWITCHES
QLOOP1:	SOJL	C,QFILE		;## IF NO SWITCH, GO QFILE
	MOVE	A,QTABLE(C)	;## GET MEMBER OF TABLE
	JSP	R,CHKGO
	JRST	.-3		;## LOOP


	;## DISPATCH TABLE FOR SWITCHES

QTABLE:
	PHASE 1
	XWD	QCOPIE,COPIES	;## /COPIES
	XWD	QCPU,CPU	;## /CPU
	XWD	QFORMS,FORMS	;## /FORMS
	XWD	QLIMIT,LIMIT	;## /LIMIT
QTABL1:	XWD	QDISP,DISP	;## /DISP (FILE DISPOSITION)

	;## EXTENDED SWITCHES

IFN QSWEXT   <
	IFE QLSTOK	<XWD QILLSW, LISTAT>
	IFN QLSTOK	<XWD QLIST, LISTAT>

	IFE QTIME <
	XWD	QILLSW,AFTER	;## /AFTER ILLEGAL (SEE ABOVE)
	XWD	QILLSW,DEAD	;## /DEAD (DEADLINE)
		>

	IFN QTIME <
	XWD	QAFTR,AFTER
	XWD	QDEAD,DEAD
		>
	XWD	QCORE,COREAT
	XWD	QMOD,MODIFY	;## /MODIFY
	XWD	QKILL,KILL	;## /KILL
	XWD	QJOB,JOB	;## /JOB
	XWD	QDEPND,DEPEND	;## /DEPEND
	XWD	QRSTR,RSTRT	;## /RESTART
	XWD	QUNIQ,UNIQUE	;## /UNIQUE
	XWD	QCORE,COREAT	;## /COREE
	XWD	QPAGES,PAGES	;## /PAGES
	XWD	QPLOT,PLOT	;## /PLOT
	XWD	QPTAPE,PTAPE	;## /PTAPE
	XWD	QCARDS,CARDS	;## /CARDS
	XWD	QSEQ,SEQ	;## /SEQ
	XWD	QPRIOR,PRIOR	;## /PRIOR (PRIORITY)
	XWD	QSPACE,SPACE	;## /SPACE (SPACING)
	XWD	QLIMIT,LIMIT	;## /LIMIT
QTABL2:	XWD	QHEAD,HEAD	;## /HEAD (HEADERS)
	>
	DEPHASE

	;##  DISPATCHING THE VARIOUS SWITCHES

IFN QSWEXT <QLIST:	HRRZI	A,4		;## HERE FOR LIST REQUEST
	CAIA
QMOD:	HRRZI	A, 5		;## /MODIFY
	CAIA
QKILL:	HRRZI	A, 6		;## /KILL
	HRRZM	A, Q.OPR(TT)
	JRST	QLOOP
	>

	;##  INPUT QUEUE ONLY SWITCHES
	;##  PUTS BYTE POINTER INTO  B  AND  THEN CHECKS TO SEE  IF SWITCH VALID IN
	;##  THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
	;##  IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)

IFN QSWEXT <
QPLOT:	JSP	R,RINPCH
	AOJA	B, QCARD+1
QPTAPE:	JSP	R, LINPCH
	AOJA	B, .+4
QCARDS:	JSP	R, RINPCH
	AOJA	B, .+4
QPAGES:	JSP	R, LINPCH
	AOJA	B, .+4
	>

QCPU:	JSP	R, RINPCH
	AOJA	B,QARG


IFN QSWEXT <
QCORE:	JSP	R, LINPCH
	AOJA	B,QARG
QDEPND:	JSP	R, RINPCH
	JRST	QARG
	>

			;##  OUTPUT  QUEUE ONLY  SWITCHES
QFORMS:	JSP	R, OUTCHK
	PUSH	P,QSXARG	;## CONVERT ARG TO SIXBIT
	MOVEM	A, Q.OFRM(TT)	;## MAKE SIXBIT IF FORMS
	JRST	QLOOP
QLIMIT:	JSP	R, OUTCHK
	MOVE	B,LINP
	AOJA	B,QARG

OUTCHK:	HLRZ	A,Q.DEV(TT)	;## GET REQUEST TYPE (THREE LETTERS)
	CAIE	A,'INP'		;## ERROR IF INPUT REQUEST
	JRST	(R)
	JRST	QILLSW

QCOPIE:	JSP	R, FILECH	;## CHECK IF WE HAVE SET UP A FILE AREA
	MOVE	B,[POINT 6,Q.FMOD(REL),35]	;## BYTE POINTER
	JRST	QARG


		;## FOR DISPOSITION, 1=PRESERVE,  2=RENAME, 3=DELETE,
		;## FIRST THREE LETTERS OF ARG TO SWITCH   UNIQUELY  IDENTIFY
		;## ILLEGAL ARG CAUSES ERROR
QDISP:	JSP	R,FILECH	;## BE SURE FILE AREA SET UP
	PUSHJ	P,QSXARG	;## MAKE ARG SIXBIT
	HLRZ	C,A		;## GET FIRST THREE LETTERS
	SETZ	A,		;## CLEAR A
	CAIN	C,'DEL'		;## DELETE AFTER OUTPUT!
	AOJA	A,.+2		;## YES!
	CAIN	C,'REN'	;## RENAME FILE OUT OF UFD?
	AOJA	A,.+3
	CAIE	C,'PRE'		;## PRESERVE IT
	JRST	QILLSW		;## HERE IF BAD ARGUMENT
	ADDI	A,1
	MOVE	B, [POINT 3, Q.FMOD(REL), 29]
	JRST	QARG+1		;## ARG ALREADY IN A
				;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
QGTARG:	MOVEI	A,(T)
	PUSHJ	P,CADAR
	SUBI	A,INUM0		;## ARG SHOULD BE AN INUM
	POPJ	P,
QARG:	PUSHJ	P,QGTARG	;## GET ARGUMENT
	DPB	A,B		;## 
	JRST	QLOOP		;## ALWAYS RETURN TO QLOOP

			;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA

LINPCH:	MOVE	B,LINP		;## GET LH BITE POINTER
	CAIA
RINPCH:	MOVE	B,RINP		;## GET RH BITE POINTER
	HLRZ	A,Q.DEV(TT)	;## GET QUEUE SPEC
	CAIN	A,'INP'		;## INP?
	JRST	(R)		;## YES
	JRST	QILLSW
LINP:	POINT	18, Q.IDEP(TT),17		;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
RINP:	POINT	18, Q.IDEP(TT),35		;## BYTE POINT FOR RH OF EXTENDED MAIN AREA


			;## HERE TO BE SURE FILE AREA HAS BEEN SET UP

FILECH:	JUMPN	REL,(R)		;## REL NONZERO IF FILE AREA SET UP
	PUSH	P,R
	JRST	FILARE
			;## HERE TO FIND FILE SPECIFICATION


QFILEA:	HRRZ	T,(T)		;## GET CDR
	SETZ	B,		;## CLEAR B
	JRST	QFILEB
QFILE:	MOVSI	A,'DSK'		;## DEFAULT IS DSK
	CAIE	REL,0		;## AREA SET UP?
	SKIPA	A,Q.FSTR(REL)	;## GET CURRENT DEVICE
	SKIPA	B,Q.PPN(TT)	;## GET USER'S PPN IF NOT SET UP
	MOVE	B,Q.FDIR(REL)	;## GET CURRENT PPN
QFILEB:	MOVEM	B,PPN		;## SET PPN
	MOVEM	A,DEV		;## HANG ON TO DEVICE
	JUMPE	T,QSELF		;## IF NIL THEN DONE
	PUSHJ	P,NXTIO		;## FAKE IOSUB SEQUENCE
	PUSHJ	P,IOPPN
	PUSH	P,A		;## IOPPN RETURNS FILE NAME IN A
	CAIE	REL,0		;## AREA SET UP?
	SKIPE	Q.FNAM(REL)	;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
	PUSHJ	P,FILARE	;## SET UP AREA
	MOVE	A,DEV		;## GET DEVICEE
	MOVEM	A,Q.FSTR(REL)	;## SET FILE STRUCTURE
	MOVE	A,EXT		;## GET EXTENSION
	MOVEM	A,Q.FEXT(REL)	;## SET IT
	MOVE	A,PPN		;## GET PPN
	MOVEM	A,Q.FDIR(REL)
	;## SET IT(DIRECTORY)
	POP	P,Q.FNAM(REL)	;## RESTORE NAME
	JRST	QSELF		;## T HAS BEEN RESET BY IO ROUTINES!



			;## HERE TO SET UP FILE AREA


FILARE:	AOS	Q.LEN(TT)	;## ADD ONE TO NUMBER FILES IN REQUEST
	HRLZI	A,FILPAR
	ADD	TT,A		;## ADD TO LENGTH OF PARAMETER AREA
	HRRZI	A,FILPAR
	PUSHJ	P,EXPCOR
	JUMPE	REL,FILDEF	;## SET DEFAULST IF NO PREVIOUS FILE AREA
	HRL	A,REL
	HRRZI	B,(A)		;## SET UP FOR BLT OF PREVIOUS AREA
	ADDI	B,FILPAR-1	;## FINAL DESTINATION ADDRESS
	HRRZI	REL,(A)		;## NEW FILE AREA
	BLT	A,(B)
	SETZM	Q.FNAM(REL)
	POPJ	P,
FILDEF:	HRRZI	REL,(A)
	HRLI	A,FILPAR
	PUSHJ	P,CLRBLK
	HRLZI	A,'DSK'
	MOVEM	A,Q.FSTR(REL)
	MOVE	A,[EXP 1B5+1B20+1B26+1B29+1]	;## DEFAULTS FOR Q.FMOD
	MOVEM	A,Q.FMOD(REL)
	POPJ	P,

			;## HERE WHEN FINISHED


QDONE:	MOVE	AR1,OUTPAR+Q.FNAM(TT)	;## GET FIRST FILE NAME
	HLRZ	A,Q.DEV(TT)	;## GET FIRST THREE LETTERS OF Q AGAIN
	CAIE	A,'INP'		;## INPUT QUEUE?
	JRST	QDONEB		;## NO
	MOVE	AR1,INPPAR+Q.FNAM(TT)	;## GET CORRCT FILE NAME
	HRRZ	A,Q.LEN(TT)	;## GET NUMBER OF FILES SPECIFIED
	SOJG	A,QDONEC	;## GREATER THAN ONE MEANS THAT USER
				;## SPECIFIED A LOG FILE
	PUSHJ	P,FILARE	;## WE HAVE TO SET UP LOG FILE
	HRRZI	A,'LOG'	;## CHANGE EXTENSION TO .LOG
	HRLZM	A,Q.FEXT(REL)
	MOVEM	AR1,Q.FNAM(REL)	;## SET TO INP FILE NAME
QDONEC:	HRRI	A,3
	DPB	A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
				;## INDICATING LOG FILE AND DOESN'T EXIST
				;## (AVOIDS ERROR MSGS FROM QMANGR)
				;## IN SECOND FILE IN CASE USER STUPIDLY SET
				;## UP MORE THAN TWO
QDONEB:	SKIPE	Q.JOB(TT)	;## SPECIFIED NAME 
	JRST	QDONE1		;## YES, DONE
	MOVEM	AR1,Q.JOB(TT)
QDONE1:	MOVE	C,[EXP 'QMANGR'];## SEGMENT NAME
	MOVEI	B,400010
	MOVE	A,TT
	PUSHJ	P,NEWHI
	PUSHJ	P,CONCOR	;## CONTRACT CORE
	JRST	FALSE		;## RETURN NIL


;## ROUTINE TO SWAP HI-SEGMENTS. REGISTER A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK  TO GETSEG  UUO
;## TO THE GET SEG

NEWHI:	PUSH	P,SP		;## HAVE TO SAVE SP, SINCE MOST
				;## SYSTEM PROGS USE 17 FOR THEIR PDL
	MOVEM	A,HIARGS#	;## SAVE ARG TO HI-SEG
	HRRZM	B,HIADDR#	;## SAVE ADDR TO HI-SEG
	PUSH	P,JOBFF		;%% SAVE OLD VALUE 
				;%% (DON'T ASK WHY)
	HLRZ	B,A		;%% CALCULATE NEW VALUE
	ADDI	B,1(A)		;%%
	MOVEM	B,JOBFF		;%% RESET SO QMANGR WON'T WRITE
				;%% OVER ARGUMENT BLOCK.
				;%% JUST BECAUSE LISP IGNORES JOBFF
				;%% DOESN'T MEAN ANYONE ELSE DOES
	MOVEM	P,PSAVE#	;## SAVE P (CAN'T USE SP)
	MOVE	SP,P		;## USE RPDL
	HRRZI	A,OLDHI		;## REE WILL RESTORE AND CONTINUE
	MOVEM	A,JOBREN
	MOVEM	A,JOBREN	;## SET FAKE REE ADDRESS
	HRLZI	B,'SYS'		;## SYS: IS LOCATION OF NEW HI-SEG
	MOVEI	A,B		;## B IS STARTING LOCATION OF BLOCK TO GETSEG
	SETZB	AR1,AR2A	;## CLEAR REST OF BLOCK
	SETZB	T,TT		;## DITTO
	MOVEM	SP,SAVSP#	;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
	JRST	NEWHI1		;## GO DO  IT

				;## HERE TO GET THAT HI-SEG

REMOTE <
NEWHI1:	CALLI	A,GETSEG
	JRST	@JOBREN		;## FAILED JOBREN HAS LOC OF RESTORE LISP HI-SEG
	MOVE	SP,SAVSP
	MOVE	A,HIARGS
	PUSHJ	SP,@HIADDR	;## JUMP TO HI-SEG
OLDHI:	MOVEI	A,HGHDAT
	CALLI	A,GETSEG
	HALT			;## YOU'RE DEAD IF YOU ARE HERE
ENDHI:	JRST	RESTOR		;## JUMP TO RESTORE THINGS
	>


RESTOR:	MOVE	P,PSAVE
	POP	P,JOBFF		;%% RESTORE OLD VALUE
	POP	P,SP
	MOVE	0,STNIL
	MOVE	S,ATMOV
	HRRZI	A,DEBUGO
	MOVEM	A,JOBREN
	POPJ	P,


TEMCOR:	HRRZ	B,CORUSE	;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
				;## BUT SAVE INFO SO THAT IT CAN BE CONTRACTED LATER
	HRL	B,JOBREL	;## GET CURRENT CORE EXTENT
	MOVEM	B,OLDCU		;## SAVE IT (SEE LOADER INTERFACE)
EXPCOR:	SETZ	D,		;## D IS A RELOC REG
	JRST	MORCOR		;## EXPAND CORE

CONCOR:	MOVS	B,OLDCU		;## CONTRACTS CORE, OPPOSITE TEMCOR
	HLRZM	B,CORUSE
	HRRZI	B,(B)		;## CLEAR LH
	PUSHJ	P,MOVDWN	;## MOVE SYMBOL TABLE
	CALLI	B,CORE		;## CONTRACT (B SHOULD BE UNCHANGED
	CAI
	POPJ	P,		;## DONE


QSXARG:	MOVEI	A,(T)
	PUSHJ	P,CADAR		;## GET ARGUMENT TO SWITCH
	JRST	SIXMAK		;## CONVERT  IT TO SIXBIT



CLRBLK:	SETZM	(A)		;## CLEAR FIRST WORD
	HLRZ	B,A		;## LH OF A CONTAINS LENGTH
	ADD	B,A
	HRL	A,A
	AOJ	A,		;## RH NOW CONTAINS SOURCE+1
	BLT	A,-1(B)		;## BLT CLEARS BLOCK
	POPJ	P,
	;## PICKUP


CHKGO:	CAIN	B,(A)		;## SEE IF RH(A)=(B)
	HLRZ	R,A		;## WHERE TO GO
	JRST	(R)		;## NO, RETURN
	>

	PAGE
	SUBTTL	PRINT
-1688,1689
	PAGE
	SUBTTL SUPER FAST TABLE DRIVEN READ 	14-MAY-69      
-1764,1765
DELIMIT (< >,3)
;## NEW ALTMODE (5S06 MONITOR)
LET (<    >)
;## 34 TO 37
-1809,1809
;## OLD ALTMODE (5S04 MONITOR)
-1831
RDNAM:	SETOM	NOINFG		;## READ ROUTINE THAT DOES NOT INTERN
	JRST	READ+1		;##

-1832:RDRUB:	MOVEI A,CR
-2028,2028

	;## FUNCTIONS TO READ A FILE.EXT
	;## READ A FILE.EXT FROM THE UFD

FLTYIA:	XCT	TYI2		;## GET NEXT WORD, IGNORE OLDCH
	JRST	TYI2X		;## INPUT SOME MORE
	ILDB	A,@TYI3		;## AND LOAD WORD
	POPJ	P,
RDFIL1:	PUSHJ	P,FLTYIA	;##  FILE NAME NOT THERE, SKIP OVER EXT
RDFILE:	SETZM	NOINFG		;## ## INTERN
	PUSHJ	P,FLTYIA		;## GET FILE NAME WORD
	PUSHJ	P,SIXATM	;## MAKE IT AN ATOM
	JUMPL	A,RDFIL1	;## A=-1 IF EMPTY 
	PUSH	P,A
	PUSHJ	P,FLTYIA		;## GET EXTENSION
	HRRI	A,0		;## CLEAR RH
	PUSHJ	P,SIXATM
	JUMPL	A,POPAJ		;## NO EXTENSION, RETURN 
	POP	P,B		;## GET FILE BACK
	JRST	XCONS		;## RETURN FILE.EXT

	;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
	;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
	;## READ MACROS, ETC.

SIXATM:	SKIPN	B,A
	JRST	SXATER		;## INDICATE WORD EMPTY
	MOVEI	T,5		;##  OF CHS PERMISSIBLE IN FULL WORD
				;## NAME T=0 IF FIRST WORD DONE
	MOVE	AR1,[POINT 6,B,5]	;## AR1 HAS PTR TO LOAD BYTE
					;## FROM B TO C
	PUSHJ	P,SIXAT1	;## MAKE THE PNAME LIST
	PUSHJ	P,NCONS
	MOVEI	B,PNAME(S)	;## MAKE PNAME
	PUSHJ	P,XCONS
	PUSHJ	P,ACONS		;## VOILA,  AN  ATOM
	SKIPE	NOINFG	;## NOINFG=0 MEANS INTERN
	POPJ	P,
	JRST	INTERN

SXATER:	SETO	A,		;## RETURN -1 IN A IF B EMPTY
	POPJ	P,
SIXAT1:	MOVE	AR2A,[POINT  7,0,35]	;## POINTER TO MOVE C TO  A
	SETZ	A,		;## CLEAR A
SIXAT2:	SETZ	C,
	JUMPE	B,SIXDON	;## DONE IF B EMPTY
	LDB	C,AR1
	LSH	B,6		;## LEFT SHIFT B, REMAINING CH'S IN B
	HRRI	C,40(C)		;## ADD 40  TO C
	IDPB	C,AR2A		;## PUT  IT IN  A
	SOJG	T,SIXAT2	;## IF T>0, STILL IN FIRST WORD OF PNAME
SIXAT3:	PUSHJ	P,FWCONS
	PUSH	P,A
	JRST	SIXAT1		;## TRY FOR THAT SIXTH CH.
SIXDON:	JUMPN	A,SIXAT3		;## IF A NOT EMTPY, DO ANOTHER FWCONS AND
				;## END UP HERE WITH A=0.
	POP	P,A
	PUSHJ	P,NCONS
	JUMPGE	T,CPOPJ		;## IF T>=0, THEN ONLY ONE WORD
	POP	P,B
	JRST	XCONS		;## DONE
;NEW AND SUPER BITCHEN READ MACROS
-2164
	PUSH P,C		;## SAVE C
	HRRZ	C,VOBLIST(S)	;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
	HRRM	C,RHX2	;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
	HRRM	C,RHX5	;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
	POP P,C		;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
			;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
-2174,2181
MAKID4:	MOVEI	B,PNAME(S)	;## USE GET FOR GETTING PNAME
	PUSHJ	P,GET		;## (GET ATOM @PNAME)
	JUMPE	A,NOPNAM	;## NO PRINT NAME
	MOVE C,IDPTR	;found pname
-2375,2375
	PAGE

		SUBTTL LISP INTERPRETER SUBROUTINES   
-2457,2461
CONSP:	JUMPE	A,CPOPJ		;## DONE IF NIL
	CAILE A,INUMIN
	JRST FALSE
	HLLE B,(A)
	AOJE B,FALSE
IFN NONUSE	<JRST	TRUE>	;## T IF NONUSEFUL DESIRED
IFE NONUSE	<POPJ	P,>	;## THE CELL OTHERWISE
-2462:PATOM:	CAIL A,@GCP1
-2466
	JUMPE	A,TRUE		;## FAST CHECK FOR NIL
	CAIGE	A,@GCP1		;## LO-END OF FWS, CAN'T ADD TO 0
-2479,2479
LNGTH1:	CAIE	A,NIL		;## DONE IF NIL
	CAIL A,@FWSO		;## FWSO  IS  FULL SPACE ORIGIN,
				;## ELIMINATE ILL MEM REF
-2487,2487
	CAIE	B,NIL		;## IF NIL DONE
	CAIL	B,@FWSO		;## ANOTHER  POTENTIAL ILL MEM GONE
-2503,2503
RPLACA:	CAIE	A,NIL		;## TEST FOR NIL
	CAILE	A,INUMIN	;$$
-2575,2576

	;## IF WE ARE USING NEW NIL, THEN GET IS FOR SYSTEM ONLY AND
	;## USRGET IS THE  USERS. IF NEW NIL, THEN GET MUST GET NIL'S
	;## PROPERTY LIST

IFE OLDNIL<
USRGET:	JUMPE	A,CPOPJ		;## ALWAYS NIL>
GET:
IFE OLDNIL<	CAIE	A,NIL
		SKIPA	A,NILPRP>
	HRRZ A,(A)
GET1:	MOVS D,(A)
-2577:	CAIN B,(D)
-2581,2581
	JUMPN A,GET1
-2584
IFE OLDNIL	<JUMPE	A,CPOPJ>	;## TEST FOR NIL
-2620,2620
PUTPROP:
IFN OLDNIL	 <MOVE T,A>
IFE OLDNIL	<SKIPN	T,A		;## CAN'T PUTPROP TO NIL
		 ERR1	[SIXBIT /CAN'T PUT PROP ON NIL !/]>
-2688,2688
-2702
COMMENT	?
	;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
	;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
	;## REPLACED BY COMPILED LISP CODE
-2703:SUBS5:	HRRZ A,SUBAS
-2714
	CAIE	C,NIL		;## TEST FOR NIL
-2735,2735
	?
-2809,2811
IFN NONUSE<MEMBER:
	>
MEMB0:	MOVEM A,SUBAS#
MEMB1:	JUMPE B,FALSE
	MOVEM B,SUBBS#
-2820,2826
IFE NONUSE<MEMQ:
	>
MEMB:	EXCH	A,B		;## NEW MEMQ THAT RETURN TAIL
	JUMPE A,FALSE
	MOVS C,(A)
	CAIN B,(C)
	POPJ	P,
	HLRZ A,C
	CAMGE	A,FWSO		;##THIS WILL ELIMINATE MOST (MAYBE ALL)
				;## ILLEGAL MEM REFS FROM MEMQ
				;##AND ASSOCIATED ROUTINES. FWSO IS FWS ORIGIN
	JUMPN A,MEMQ+1
	POPJ	P,
-2833,2833
IFE NONUSE<MEMBER:
	>
MEMBR.:	PUSHJ P,MEMB0
-2834:	SKIPE A
-2838,2840
IFN NONUSE<
MEMQ:	PUSHJ P,MEMB
	SKIPE A
	JRST	TRUE
-2844,2844
;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
-2851
	>
-2872,2873
IFN	NONUSE <
	SKIPE A
	MOVEI A,TRUTH(S)
	>
-3013,3014
	HLRZ TT,(A)	;## TT HAS VARIABLE LIST
	HRRZ A,(A)	;## A HAS PROG BODY
-3015:	HRRM A,PA4
-3032,3040
	JUMPE T,PG4	;## IF END OF PROG, QUITE
	HLRZ A,(T)	;## A HAS FIRST STATEMENT
	HRRZ T,(T)	;## T KEEPS THE REST
	CAIE	A,NIL	;## TEST FOR NIL
	CAILE A,INUMIN	;## ALLOW INUMS FOR PROG LABELS 3/28/73
	JRST	PG1+1	;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
	HLLE B,(A)	;## IS IT A ATOM?
	AOJE B,PG1+1	;## JA, SO JUMP
	HRRM T,PA4	;## SAVE REST OF BODY

	PUSH P,SP	;$$SAVE SPDL TO RESTORE AFTER EVAL
	PUSHJ P,EVAL	;## EVAL THE STATEMENT
-3045,3056
PGO:	SKIPN	PA3	;## ERROR IF NO PROG
	JRST	EG2
	MOVE	P,PA3	;## BACK UP ON RPDL
	MOVE	B,1(P)	;## GET FORM
	PUSHJ	P,UBD
	HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
			;## AND TRACING OF GO
	PUSHJ	P,DOSET	;##
	HLRZ	T,PA4
PG5:	JUMPE T,EG1	;## ERROR IF NO TAG FOUND
	HLRZ TT,(T)	;## GET THE CAR
	HRRZ T,(T)	;## SAVE UP THE REST OF THE BODY
	CAIN TT,(A)
	JRST PG1+1	;FOUND TAG
	JRST PG5	;## TRY AGAIN
-3063,3063
	HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
				;## AND TRACING OF RETURN
	PUSHJ	P,DOSET		;##
	JRST	PG4+1

-3071,3071
	CAIE	A,NIL		;## TEST FOR NIL
	CAILE	A,INUMIN	;## IS IT AN INUM?(NOW VALID)
	JRST	PGO		;## SEE IF IT IS THE ONE
	HLLE B,(A)	;## IS IT AN ATOM
-3155,3155

		SUBTTL ARITHMETIC SUBROUTINES 
-3156:
-3227,3227
	CAIE	B,FLONUM(S)	;## DEFAULT TO FIXNUM, NOT FLONUM
-3291

NUMTYP:	PUSHJ	P,NUMVAL	;## NUMVAL LEAVES TYPE IN B
	MOVEI	A,(B)		;## GET THE TYPE
	POPJ	P,

INUMP:	CAIG	A,INUMIN	;##  INUM IF > INUMIN
	JRST	FALSE		;## NO, RETURN NIL
	POPJ	P,		;## RETURN USEFUL VALUE
-3360,3360
-3401,3402
	PAGE

		SUBTTL EXPLODE, READLIST AND FRIENDS 
-3500,3501

-3502:
-3536,3536
	PAGE
		SUBTTL EVAL APPLY  -- THE INTERPRETER  
-4038,4039
	PAGE

		SUBTTL ARRAY SUBROUTINES  
-4172
GTBLK:	MOVNI C,-INUM0(A)	;##COMPUTE NEGATIVE LENGTH
	MOVE A,VBPORG(S)	;## GET BPORG
	HRRI A,-INUM0(A)	;## CONVERT
	HRLM C,(A)		;## MOVE TO BPORG INFO FOR (GC)
	HRRM A,(A)		;##
	AOS R,(A)		;## ADD ONE TO INFO AND MOVE TO R
	SUBI R,1		;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
	CAIN B,0		;## IS IT A POINTER BLOCK?
	SUBI R,1		;## NO
	MOVE AR1,VBPEND(S)	;## GET BPEND
	MOVNI AR1,-INUM0(AR1)	;## CONVERT TO NEGATIVE
	ADD AR1,R		;## BPORG-BPEND +(0 OR 1)
	HRLI R,(AR1)		;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
	PUSH R,[0]		;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
	AOJN C,.-1		;## WE WILL ALSO CLEAR THE INFO LOCATION
	HRRZI R,INUM0+1(R)	;## COMPUTE NEW BPORG
	HRRM R,VBPORG(S) 
	CAIN B,0		;## IF IT WAS NOT A POINTER BLOCK, DONE
	POPJ P,
	MOVE B,GCMKL		;## GET GC'S LIST
	PUSHJ P,CONS		;## CONS
	MOVEM A,GCMKL		;## SAVE IT
	HLRZ A,(A)		;GET THE OLD BPORG BACK
	AOJA A,.-5		;## ADD ONE AND RETURN


BLKLST:	PUSH	P,A		;## SAVE LIST
	CAIE	B,0		;## BLK LENGTH GIVEN
	SKIPA	A,B		;## YES
	PUSHJ	P,LENGTH	;## NO, USE LENGTH OF LIST
	MOVEI	B,(A)		;## GET A POINTER BLOCK FROM GTBLK
	PUSHJ	P,GTBLK
	POP	P,B		;## GET LIST BACK
	PUSH	P,A
	HRRZI	R,-1(A)		;## SET UP PDL
	HLRE	C,(R)		;## NEG LENGTH FROM GC INFO.
BLKLS1:	HRRI	A,1(A)		;## BUMP A FOR CDR

IFN	OLDNIL<			;## IF(CDR NIL)#NIL
	TRNE	B,-1		;## END OF LIST?
	SKIPA	B,(B)		;## NO
	SETZ	B,		;## YES,  REST  OF BLOCK IS NIL
	>

IFE OLDNIL<
	MOVE	B,(B)		;##  IF  (CDR  NIL )=NIL
	>

	HLL	A,B		;## GET (CAR LIST)
	PUSH	R,A		;## AND STORE
	AOJL	C,BLKLS1	;## SEE IF DONE
	HLLZM	A,(R)		;## SET (CDR (LAST BLOCK)) TO NIL
	JRST	POPAJ		;## AND RETURN POINTER TO THE BLOCK


-4198,4199
	
	PAGE

		SUBTTL EXAMINE, DEPOSIT , ETC 
-4240,4241

	PAGE

		SUBTTL GARBAGE COLLECTER   
-4242:
-4251
IFE OLDNIL	<PUSH	P,NILPRP	;##  PROP LIST OF NIL>
-4256
	PUSH	P,INITF1	;## INIT FILE LIST
-4449,4450
	
	PAGE
	SUBTTL	SYMBOL TABLE ACCESSING ROUTINES

-4465


	;## NEW ROUTINES FOR CONVERTING  SYMBOLS TO CONS CELL

SYMERR:	MOVE	A,B
SYMER1:	PUSHJ	P,EPRINT		;## PRINT OFFENDER
	ERR1	[SIXBIT /NOT A CONS CELL !/]
	;## **CAUSES ERROR IF NOT IN FREE STORAGE**
RGTSYM:	PUSHJ	P,GETSYM
	PUSHJ	P,NUMVAL	;## CONVERT TO REAL ADDRESS
	ADDI	A,(S)		;## ADD  RELOCATION
	CAIL	A,FS(S)		;## LESS THAN FS(S) IS NOT CONS CELL
	CAML	A,FWSO		;## FS(S)<= A < FWSO IS A CONS CELL
	JRST	SYMER1
	POPJ	P,

-4480

	;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
	;## REFERENCED VIA  ,CELL(S) I.E. THRU INDEX REG. S
	;## ERROR IF NOT LEGITIMATE CONS CELL
RPTSYM:	CAIL	B,FS(S)		;## FS(S) =< B <FWSO IS A LEGIT
	CAML	B,FWSO		;## CONS CELL, ALL ELSE IS ERROR
	JRST	SYMERR		;## ERROR
	SUBI	B,(S)		;## STRIP OF RELOCATION

-4481:PUTSYM:	PUSH P,B
-4495,4538
	PAGE
	SUBTTL	SPRINT -- THE PRETTY PRINTER


-4934

		SUBTTL ALVINE AND LOADER INTERFACES   

;interface to alvine

IFN ALVINE,<
ED:	MOVE 10,EDA
	JRST (10)
	PUSH P,A
	HRRZ A,CORUSE
	HRRM A,LST
	AOS A
	HRRM A,EDA#


	HRRM	A,ED1	;$$SAVE REENTRY TO EDITOR
	AOS	ED1#	;$$

	MOVSI A,(SIXBIT /ED/)
	SETZ	D,	;THAT RELOCATION AGAIN - SEE BELOW
	PUSHJ P,SYSINI
	HRLM A,LST	
	MOVNS A
	PUSHJ P,MORCOR
	PUSHJ P,SYSINP+1
	POP P,A
	JRST ED
GRINDEF:PUSH P,A
	PUSHJ P,ED
	POP P,A
	JRST 2(10)>

EXCISE:
IFN ALVINE<
	MOVEI A,ED+2
	HRRM A,EDA>
	MOVE A,JRELO
	SETZM LDFLG#	;initial loader symbol table flag
	CALLI A,CORE
	JRST .+1
	JSP R,IOBRST
	JRST TRUE

PAGE

-5015,5015
-5028
	;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
	COMMENT &
-5035
	&		;%% END OF OLD CODE
	;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
	MOVE	A,SYSIN1(D)	;%% PICK UP PPN
REMOTE<
SYSIN1:	XWD	SYSPRG,SYSPN	;%% KEEP IN LOW SEGMENT
>
	MOVEM	A,NAME+3(D)	;%% RESET VALUE HERE
	MOVEI	A,17		;%% SET DATA MODE 
	MOVEM	A,SYSIN0(D)	;%%
	OPEN	0,SYSIN0(D)	;%% OPEN CHANNEL 0 TO READ FILE
	JRST	AIN.4+1		;%% ERROR IN OPEN IF HERE
REMOTE<
SYSIN0:	17			;%% DUMP MODE I/O
	SYSDEV			;%% INITIALLY SYSTEM DEVICE
				;%% MAY BE PATCHED
				;%% NOTE THAT THIS MAY REMAIN "SYS"
				;%% WHEN HGHDAT IS CHANGED TO
				;%% SOMETHING ELSE
	0			;%% NO BUFFERING
>
-5036:	LOOKUP NAME(D)
-5049,5049
NAME:	SIXBIT/ILISP/
-5065,5065
MOVDWN:	HRLM	B,JOBSA	;##SAVE NEW JOBSA
	HLRZ A,JOBSYM
-5100,5100
	SUBM	A,B	;NEEDED-JOBSYM-CORUSE(IE.  NEEDED-FREE)
-5128,5131
	HRLZ	A,B
	CALLI	A,CORE
-5156
	SETZM	DEV	;## ALLOW DEFAULT TO DSK:
-5158,5163
	CAME	A,[SYSNAM]	;				*** MJC
; We're not allowing him to name his segment the same as ours,	*** MJC
;   since that causes problems for ATTSEG, so test for it.	*** MJC
	JRST	GUDSEG	;					*** MJC
	MOVE	B,[SYSDEV]	; But if he's a system hacker	*** MJC
	CAME	B,DEV		;   then we let him get away	*** MJC
	JRST	BADSEG		;   with it.			*** MJC
GUDSEG:	MOVEM	A,HGHDAT+1	;SAVE THE FILE NAME
	MOVE	A,DEV		;GET THE DEVICE AND SAVE IT
	MOVEM	A,HGHDAT
	MOVEM	A,INTDAT+1	; Save it for OPEN, too.	*** MJC
	MOVE	A,PPN		;GET THE PPN AND SAVE IT
	MOVEM	A,SGPPPN	;				*** MJC
	MOVEM	A,HGHDAT+4
	SKIPN	A,EXT		; Get extension and save it.	*** MJC
	MOVE	A,[SIXBIT/SEG/]	; No ext -- use SEG instead.	*** MJC
	MOVEM	A,HGHDAT+2	; Move ext into OPEN stuff.	*** MJC
	OPEN	0,INTDAT  	; Open for dump output.		*** MJC
	JRST	BADSEG		; Couldn't open?		*** MJC
	ENTER	0,HGHDAT+1	; Hookup to file.		*** MJC
	JRST	BADSEG		; Couldn't do it?		*** MJC
	CALLI	A,400022	; Find size of high segment.	*** MJC
	MOVNS	A		; Construct dump mode cmd wd.	*** MJC
	HRLM	A,HGHDAT+4	; I.e. -length to left half	*** MJC
	MOVEI	A,SHRST-1	;   and <start>-1 to rt half.	*** MJC
	HRRM	A,HGHDAT+4	;				*** MJC
	OUTPUT	0,HGHDAT+4	;				*** MJC
	CLOSE	0,2		; Leave no traces		*** MJC
	JRST	FALSE		;RETURN NIL
BADSEG:	ERR1	[SIXBIT/ILLEGAL NAME FOR SEGMENT!/] ;		*** MJC
	JRST	FALSE	;					*** MJC
-5167,5167

		SUBTTL REALLOC CODE     
-5168:
-5360,5363
	HRRM	B,GCP5		;TOP OF BIT TABLES
	ADDI	B,1		;BOTTOM OF REG PDL

	MOVE	S,ATMOV		;## S NOT SET IF LISP STARTED WITH CORE
				;## ALREADY EXPANDED, SO RESET IT
	HRRZI	A,OBTBL(S)	;GET OBLIST POINTER
				;## RHX2 IS NO LONGER PURE, WE WANT THE SYSTEM OBLIST
				;## THIS IS IT (I HOPE)3/28/73
-5451
	SKIPE	INITF1		;## DON'T FORGET THE INIT FILES
	ADDM	FF,INITF1	;##
-5480,5484
IFE OLDNIL<	ADDM	A,NILPRP>	;## RESET NIL
	HRR	B,VOBLIST(S)	;## GET CURRENT VALUE OF OBLIST
	HRRM	B,RHX5		;## RESET WORD THAT POSTINDEXES OFF B
	HRRM	B,RHX2		;## RESET WORD POSTINDEXING OFF C
	ADDM	A,XXX3		;## RESET WIERD CODE 
	ADDM	A,XXX4		;## RESET UNBOUND
	ADDM	A,XXX5		;## RESET FS (SAME WORD AS FS),ALSO GCPP1
-5497,5497
-5516,5516
BANGCK:	CAIE	C,CR	;## TERMINATE ON CR,NOT LF
-5517:	JRST	(R)
-5567,5567

-5694,5696
PAGE
	SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
-5702,5702
	SUBTTL LISP ATOMS AND OBLIST	
-5730


;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM

-5740
;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME

-5741:DEFINE MKAT1 (A,B,C,D)
-5749

-5752

;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
-5758
;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP

-5770
;##  ATOM WITH NO PROPS WITH  LABEL SAME AS ATOM NAME

-5777
;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM

-5778:DEFINE MK (A)<
-5794,5794
;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
IFN NONUSE<
MKAT1 MEMBR.,SUBR,MEMBER#
MKAT1 MEMB,SUBR,MEMQ#
MKAT1 AND.,FSUBR,AND#
MKAT1 OR.,FSUBR,OR#
	>
MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR>,SUBR
-5799,5799
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
-5823,5823
;##LIST STARTS HERE
MKAT LIST,FSUBR,,LISTAT:

MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR 
-5838,5838
;## LABELS ON READ AND LISP EVAL FOR BOOTS
MKAT READ,SUBR,,READAT:
MKAT EVAL,LSUBR,O,EVALAT:
-5881
MKAT1 RPTSYM,SUBR,*RPUTSYM
MKAT1 RGTSYM,SUBR,*RGETSYM
-5882:
-5897

;## QUEUE ATOMS AND OTHER NEW FNS.

MKAT<GTBLK,ERRCH,RDNAM>,SUBR
MKAT<INUMP,NUMTYPE>,SUBR
MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
MKAT<QUEUE,RENAME,DELETE,INITFL>,FSUBR
ML<CPU,FORMS,LIMIT,COPIES,DISP>
MK<SUBST,COPY,*RENAME,FILBAK,LBK,DIR>
MKAT1 ISFILE,SUBR,LOOKUP
MK<NO BACKUP >

;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
IFN	QSWEXT<
	ML<DEAD,AFTER>
	ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
	ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
	>		;##END OF EXTENDED SWITCHES

-5911,5911
	MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR 
-5920,5923
-5953
MK<USERERRORX,RPUTSYM,RGETSYM>
-5981,5981
MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO> ;##REMOVE MARKER
-5982:MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
-6019,6019

		SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) 
-6059
;##DEBUG QUEUE
MKENT <CADAR,ATMOV,CADAR,COPIES,CORUSE,DEBUGO,DEV>
MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
MKENT <NXTIO,OLDCU,SIXMAK,STNIL>
-6063,6063
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
-6075
;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
MKENT <TYO5,AIOP,SETIN>

-6079,6081
;%% FOR THE MODIFIED ARITHMETIC PACKAGE
MKENT <FIXNUM,FLONUM>

PAGE
	END ALLOC

-6082:UB>